home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / zebu v3.3.3 (LALR parser) / zebu-lr0-sets.lisp < prev    next >
Encoding:
Text File  |  1994-09-12  |  6.8 KB  |  198 lines  |  [TEXT/ttxt]

  1. ; -*- mode:     CL -*- ------------------------------------------------- ;
  2. ; File:         zebu-lr0-sets.l
  3. ; Description:  Conversion to CL of the original Scheme program by (W M Wells)
  4. ; Author:       Joachim H. Laubsch
  5. ; Created:      31-Oct-90
  6. ; Modified:     Fri Apr 23 10:00:40 1993 (Joachim H. Laubsch)
  7. ; Language:     CL
  8. ; Package:      ZEBU
  9. ; Status:       Experimental (Do Not Distribute) 
  10. ; RCS $Header: $
  11. ;
  12. ; (c) Copyright 1990, Hewlett-Packard Company
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; Revisions:
  15. ; RCS $Log: $
  16. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17. ;;;             Copyright (C) 1989, by William M. Wells III
  18. ;;;                         All Rights Reserved
  19. ;;;     Permission is granted for unrestricted non-commercial use.
  20.  
  21.  
  22. ;;; This defines the representation for sets of items, and
  23. ;;; computes the canonical lr(0) collection of sets of items.
  24. ;;; It currently leaves the closures lying around on the sets
  25. ;;; of items, they could be flushed just after they are used.
  26. ;;; It gets hold of the grammar via the symbol 'augmented start
  27. ;;; and the application of g-symbol-own-productions to symbols.
  28. ;;; The grammar should have been previously internalized
  29. ;;; using load-grammar.
  30.  
  31. (in-package "ZEBU")
  32.  
  33. (defvar *lr0-item-set-count*)
  34. (defvar *lr0-item-sets*)
  35. (defvar *lr0-start-state-index*)
  36. (declaim (fixnum *lr0-start-state-index*))
  37.  
  38. ;;; A type for sets of items.
  39. ;;; The kernel will be a o-set of items, the closure might be
  40. ;;; an o-set, or might be null if we are trying to save space.
  41. ;;; goto-map will be a oset of pairs whose cars are grammar symbols
  42. ;;; and whose cdrs are item-sets.
  43.  
  44. (defstruct (item-set (:print-function
  45.               (lambda (item-set stream depth)
  46.             (declare (ignore depth))
  47.             (item-set-print-kernel item-set nil stream))))
  48.   index
  49.   kernel
  50.   (closure ())
  51.   goto-map)
  52.  
  53. (defun item-set-print-kernel (item-set closure-too? &optional (stream t))
  54.   (oset-for-each
  55.    #'(lambda (item)
  56.        (item-print item stream) (terpri stream))
  57.    (if closure-too?
  58.        (item-set-get-closure! item-set)
  59.      (item-set-kernel item-set))))
  60.  
  61. (declaim (inline goto-map-order-function item-set-order-function
  62.         new-item-set))
  63.  
  64. (defun goto-map-order-function (a b)
  65.   (g-symbol-order-function (car (the cons a)) (car (the cons b))))
  66.  
  67. (defun new-item-set (kernel)
  68.   (make-item-set :kernel kernel
  69.          :goto-map (make-oset
  70.                 :order-fn #'goto-map-order-function)))
  71.  
  72.  
  73. ;;; Item sets can be identified by looking at their kernels, so:
  74. (defun item-set-order-function (a b)
  75.   (declare (type item-set a b))
  76.   ;; (oset-order-function (item-set-kernel a) (item-set-kernel b))
  77.   ;; expand call for efficiency
  78.   (let* ((oset-a (item-set-kernel a))
  79.      (oset-b (item-set-kernel b))
  80.      (odf (oset-order-fn oset-a)))
  81.     (labels ((oset-order-aux (ilista ilistb)
  82.            (if (null ilista)
  83.            'equal
  84.          (let ((item-order
  85.             (funcall odf
  86.                  (car (the cons ilista))
  87.                  (car (the cons ilistb)))))
  88.            (if (eq 'equal item-order)
  89.                (oset-order-aux
  90.             (cdr (the cons ilista)) (cdr (the cons ilistb)))
  91.              item-order)))))
  92.       (if (eq odf (oset-order-fn oset-b))
  93.       (let ((a-card (oset-cardinality oset-a))
  94.         (b-card (oset-cardinality oset-b)))
  95.         (declare (fixnum a-card b-card))
  96.         (if (< a-card b-card)
  97.         'correct-order
  98.           (if (= a-card b-card)
  99.           ;; same cardinality, same type, so march down the lists...
  100.           (oset-order-aux (oset-item-list oset-a)
  101.                   (oset-item-list oset-b))
  102.         'wrong-order)))
  103.     (error "incompatible types of sets: oset-order-function")))))
  104.  
  105. ;;; Result is an oset of item-sets which comprise the canonical
  106. ;;; lr(0) sets of items.
  107.  
  108. (defun make-lr0-collection ()
  109.   (let* ((lr0-set (make-oset :order-fn #'item-set-order-function))
  110.      (start-prod (car (g-symbol-own-productions
  111.                *augmented-start-g-symbol*)))
  112.      (initial-kernel
  113.       (make-oset
  114.        :item-list   (list (new-item start-prod))
  115.        :order-fn    #'item-order-function
  116.        :cardinality 1)))
  117.     (let ((initial-state (new-item-set initial-kernel)))
  118.       (lr0-insert-item-set! initial-state lr0-set)
  119.       (setf *lr0-item-set-count* 0)
  120.       (dolist (is (oset-item-list lr0-set))
  121.     (setf (item-set-index is) (post-inc *lr0-item-set-count*)))
  122.       (setf *lr0-start-state-index* (item-set-index initial-state))
  123.       (format t "~S item sets~%" *lr0-item-set-count*) 
  124.       (setf *lr0-item-sets* lr0-set)
  125.       '())))
  126.  
  127. ;----------------------------------------------------------------------------;
  128. ; lr0-insert-item-set!
  129. ;---------------------
  130. ; item-set should be of that type.
  131. ; Collection should be an o-set of item-sets.
  132. ; Returns a pointer to the item set in the collection.
  133.  
  134. (defun lr0-insert-item-set! (item-set collection)
  135.   (multiple-value-bind (inserted? the-item)
  136.       (oset-insert-2! item-set collection)
  137.     (when inserted?            ; item wasn't already there
  138.       (let ((item-set-goto-map (item-set-goto-map item-set)))
  139.     (princ ".")
  140.     (dolist (subset (oset-select-subsets
  141.              (item-set-get-closure! item-set)
  142.              #'symbol-after-dot))
  143.       (declare (type oset subset))
  144.       ;; (assert (typep subset 'oset))
  145.       ;; subset is an oset of items with same after dot
  146.       (let ((subset-item-list (oset-item-list subset)))
  147.         (when subset-item-list
  148.           (let ((goto-set (make-oset :order-fn #'item-order-function)))
  149.         (dolist (item subset-item-list)
  150.           (let ((next (advance-dot item)))
  151.             (if next (oset-insert! next goto-set))))
  152.         (unless (oset-empty? goto-set)
  153.           (oset-insert!
  154.            (cons (symbol-after-dot (car subset-item-list))
  155.              (lr0-insert-item-set! (new-item-set goto-set)
  156.                            collection))
  157.            item-set-goto-map))))))))
  158.     the-item))
  159.  
  160. ;;; Returns the oset of items which is the closure of the item
  161. ;;; set, calculating it if need be from the kernel.
  162. ;;; Caches the closure in the closure slot.
  163. (defun item-set-get-closure! (item-set)
  164.   (or (item-set-closure item-set)
  165.       (setf (item-set-closure item-set) (closure (item-set-kernel item-set)))))
  166.  
  167.  
  168. ;;; This isn't used in the current implementation: Sep 13, 1989.
  169. #||
  170. (defun item-set-flush-closure (item-set)
  171.   (setf (item-set-closure item-set) '()))
  172.  
  173. ;; inline expanded in lr0-insert-item-set!
  174. ;;; Subset is an oset of items which all have the same after dot symbol.
  175. ;;; Result is an oset of items.
  176. ;;; Gives back an empty set if the dots are all the way to the right
  177. ;;; in the input set.
  178.  
  179. (defun goto (subset)
  180.   (let ((result (make-oset :order-fn #'item-order-function)))
  181.     (dolist (item (oset-item-list subset) result)
  182.       (let ((next (advance-dot item)))
  183.     (if next (oset-insert! next result))))))
  184. ||#
  185.  
  186. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  187. ;;; test:
  188. #||
  189. (load-grammar "ex1.zb")
  190. (make-lr0-collection)
  191. (print-collection nil)
  192. (print-collection t)
  193. ||#
  194.  
  195. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  196. ;;                           End of zebu-lr0-sets.l
  197. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  198.